home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / examples.zoo / misc / intmisc.lsp < prev    next >
Lisp/Scheme  |  1991-10-22  |  1KB  |  48 lines
  1. ;; Verschiedene Funktionen für Integers
  2. ;; Bruno Haible 25.4.1989, 5.9.1990
  3.  
  4. (provide 'intmisc)
  5.  
  6. ; exakter Quotient von Integers, schneller als / :
  7. #-CLISP
  8. (defun exquo (a b)
  9.   (multiple-value-bind (q r) (floor a b)
  10.     (unless (zerop r) (error "Quotient ~S/~S nicht exakt." a b))
  11.     q
  12. ) )
  13.  
  14. ; Fakultät:
  15. #-CLISP
  16. (defun ! (n)
  17.   (assert (and (integerp n) (>= n 0))
  18.           (n)
  19.           "Argument muß eine natürliche Zahl sein, nicht ~S" n
  20.   )
  21.   (do* ((p 1 (* p i))
  22.         (i n (- i 1)))
  23.        ((zerop i) p)
  24. ) )
  25.  
  26. ; Installiert eine Funktionsdefinition einer auf N0 definierten Funktion
  27. ; (mit NIL nicht im Wertebereich) mit "Gedächtnis" unter name:
  28. (defmacro defun-N0 (name (var) &body body &environment env)
  29.   (multiple-value-bind (body-rest declarations)
  30.                        (sys::parse-body body nil env)
  31.     (if declarations
  32.       (setq declarations (list (cons 'DECLARE (nreverse declarations))))
  33.     )
  34.     (let ((remember (gensym)))
  35.       `(let ((,remember (make-array 0 :adjustable t :initial-element nil)))
  36.          (defun ,name (,var)
  37.            ,@declarations
  38.            ; (assert (typep ,var '(integer 0 *))) ; Typtest
  39.            (assert (and (integerp ,var) (>= ,var 0))) ; explizit
  40.            (unless (< ,var (length ,remember))
  41.              (setq ,remember (adjust-array ,remember (+ ,var 1 50)))
  42.            )
  43.            (or (aref ,remember ,var)
  44.                (setf (aref ,remember ,var) (progn ,@body-rest))
  45.        ) ) )
  46. ) ) )
  47.  
  48.